home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1995 August: Tool Chest / Dev.CD Aug 95 TC / Dev.CD Aug 95 TC.toast / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / Matts-utils.sea / Matts-utils / when-strings.lisp / when-strings.lisp
Encoding:
Text File  |  1992-09-06  |  19.5 KB  |  503 lines  |  [TEXT/CCL2]
  1. ;;;
  2. ;;; when-strings.lisp
  3. ;;;
  4.  
  5. #|
  6. ================================================================
  7. Purpose ========================================================
  8. ================================================================
  9. Defines functions for decoding when-strings, which are strings encoding
  10. possibly repeating times and dates.
  11.  
  12. Fields:
  13. A when-string is a string that contains fields for times, days, months,
  14. and years. The only valid field types follow.
  15.  
  16.  
  17. Field types:
  18. :time - Specified in military format. Both the hour and minute are
  19. required in this format "HH:MM" where H and M are decimal natural numbers.
  20. Examples are 20:30 (e.g. 8:30pm) and 02:15 (e.g. quarter past 2am). The
  21. hour is between 00 and 23 inclusive and the minute is between 00 and 59
  22. inclusive.
  23.  
  24. :day-of-week - Specified as one of these strings of three characters: Mon,
  25. Tue, Wed, Thu, Fri, Sat, Sun.
  26.  
  27. :date-number - Specified as a string of two natural numbers between 1 and
  28. 31 inclusive.
  29.  
  30. :month - Specified as one of these strings of three characters: Jan, Feb,
  31. Mar, Apr, May, Jun, Jul, Aug, Sep, Oct, Nov, Dec.
  32.  
  33. :year - Specified as four natural numbers. Examples are 1992 and 1804.
  34.  
  35.  
  36. Constraints:
  37. Fields are delimited (separated) by #\- (a dash).
  38. Case is ignored.
  39. There must be exactly zero or one of each type of field.
  40. Must specify a :month with a :date-number.
  41.  
  42.  
  43. ================================================================
  44. Status =========================================================
  45. ================================================================
  46. Implemented.
  47.  
  48. Bug/Fix: Should be able to specify just a date without a month or year,
  49. e.g. 01, which would match the first of every month of every year.
  50.  
  51.  
  52. ================================================================
  53. Change history =================================================
  54. ================================================================
  55. 14-Aug-92 mc    Created.
  56. 17-Aug-92 mc    Updated for new operations.
  57.         Decided to not handle :relative-day-specifier .
  58. 18-Aug-92 mc    Defined f-when-str-matches-month .
  59.         Fixed bug in field-spec-from-str-field when checking for :time .
  60. 19-Aug-92 mc    Noted Bug/Fix above .
  61. 06-Sep-92 mc    Changed when-string-now to use f-include-hour-and-minute .
  62.  
  63. |#
  64.  
  65.  
  66. (in-package "COMMON-LISP-USER")
  67.  
  68.  
  69. (export '(F-VALID-WHEN-STR
  70.           F-WHEN-STR-MATCHES-DATE
  71.           F-WHEN-STR-MATCHES-MONTH
  72.           DECODE-WHEN-STR
  73.           WHEN-STRING-MAKE
  74.           WHEN-STRING-NOW)
  75.         "COMMON-LISP-USER")
  76.  
  77.  
  78. ;;;================================================================
  79. ;;; Define when-string operations.
  80. ;;;================================================================
  81.  
  82. (defgeneric f-valid-when-str (when-string)
  83.   (:documentation "Returns non-nil if when-string specifies a valid
  84. when-string."))
  85.  
  86.  
  87. (defmethod f-valid-when-str ((when-string string))
  88.   (declare (optimize speed))
  89.   ;;
  90.   (l-field-specs-from-when-str when-string))
  91.  
  92.  
  93. (defgeneric f-when-str-matches-date (when-string
  94.                                       int-date-number int-month-number int-year)
  95.   (:documentation "Returns non-nil if when-string matches int-date-number,
  96. int-month-number, and int-year."))
  97.  
  98.  
  99. (defmethod f-when-str-matches-date ((when-string string)
  100.                                      (int-date-number integer)
  101.                                      (int-month-number integer)
  102.                                      (int-year integer))
  103.   (declare (optimize speed))
  104.   ;;
  105.   (let* ((l-field-specs (l-field-specs-from-when-str when-string))
  106.          (f-valid-when-str l-field-specs)
  107.          (f-when-str-matches t)
  108.          int-day-of-week)
  109.     ;;
  110.     (unless f-valid-when-str
  111.       (error "~S is not a valid when-string." when-string))
  112.     ;; Set int-day-of-week .
  113.     (let ((ut (encode-universal-time 0 0 0
  114.                                      int-date-number int-month-number int-year)))
  115.       (multiple-value-bind (second minute hour date month year day-of-week)
  116.                            (decode-universal-time ut)
  117.         (declare (ignore second minute hour date month year))
  118.         ;;
  119.         (setf int-day-of-week day-of-week)))
  120.     ;;
  121.     ;; Matches if every field in l-field-specs matches the passed values
  122.     ;;
  123.     (dolist (field-spec l-field-specs)
  124.       (let ((kw-field-type (first field-spec))
  125.             (field-value (second field-spec)))
  126.         (when (and (member kw-field-type
  127.                            '(:date-number :month :year :day-of-week))
  128.                    (not (f-field-spec-matches-value
  129.                            kw-field-type field-value
  130.                            int-day-of-week int-date-number int-month-number int-year)))
  131.           (setf f-when-str-matches nil))))
  132.     f-when-str-matches))
  133.  
  134.  
  135. (defgeneric f-when-str-matches-month (when-string int-month-number int-year)
  136.   (:documentation "Returns non-nil if when-string matches int-month-number
  137. and int-year."))
  138.  
  139.  
  140. (defmethod f-when-str-matches-month ((when-string string)
  141.                                      (int-month-number integer)
  142.                                      (int-year integer))
  143.   (declare (optimize speed))
  144.   ;;
  145.   (let* ((l-field-specs (l-field-specs-from-when-str when-string))
  146.          (f-valid-when-str l-field-specs)
  147.          (f-when-str-matches t))
  148.     ;;
  149.     (unless f-valid-when-str
  150.       (error "~S is not a valid when-string." when-string))
  151.     ;;
  152.     ;; Matches if every field in l-field-specs matches the passed values
  153.     ;;
  154.     (dolist (field-spec l-field-specs)
  155.       (let ((kw-field-type (first field-spec))
  156.             (field-value (second field-spec)))
  157.         (when (and (member kw-field-type '(:month :year))
  158.                    (not (f-field-spec-matches-value
  159.                            kw-field-type field-value
  160.                            nil nil int-month-number int-year)))
  161.           (setf f-when-str-matches nil))))
  162.     f-when-str-matches))
  163.  
  164.  
  165. (defgeneric decode-when-str (when-string)
  166.   (:documentation "Returns six values from when-string: int-minute,
  167. int-hour, int-date-number, int-month-number, int-year, and
  168. int-day-of-week. All values are as decode-universal-time returns.
  169. Returns nil for any value that can't be determined."))
  170.  
  171.  
  172. (defmethod decode-when-str ((when-string string))
  173.   (declare (optimize speed))
  174.   ;;
  175.   (let* ((l-field-specs (l-field-specs-from-when-str when-string))
  176.          (f-valid-when-str l-field-specs)
  177.          (int-minute nil)
  178.          (int-hour nil)
  179.          (int-date-number nil)
  180.          (int-month-number nil)
  181.          (int-year nil)
  182.          (int-day-of-week nil))
  183.     ;;
  184.     (unless f-valid-when-str
  185.       (error "~S is not a valid when-string." when-string))
  186.     ;;
  187.     ;; Set each of the result vars if its kw-field-type is on l-field-specs
  188.     ;;
  189.     (dolist (field-spec l-field-specs)
  190.       (let ((kw-field-type (first field-spec))
  191.             (field-value (second field-spec)))
  192.         (case kw-field-type
  193.           (:time (setf int-hour (first field-value)
  194.                        int-minute (second field-value)))
  195.           (:date-number (setf int-date-number field-value))
  196.           (:day-of-week (setf int-day-of-week field-value))
  197.           (:month (setf int-month-number field-value))
  198.           (:year (setf int-year field-value)))))
  199.     ;; Return the results.
  200.     (values int-minute int-hour
  201.             int-date-number int-month-number int-year
  202.             int-day-of-week)))
  203.  
  204.  
  205. (defgeneric when-string-make (&key int-minute int-hour
  206.                                     int-date-number int-month-number int-year
  207.                                     int-day-of-week)
  208.   (:documentation "Returns a when string that properly encodes the non-nil
  209. passed values. Errors if it can't construct a valid when-string from the
  210. arguments."))
  211.  
  212.  
  213. (defmethod when-string-make (&key int-minute int-hour
  214.                                    int-date-number int-month-number int-year
  215.                                    int-day-of-week)
  216.   (declare (optimize speed))
  217.   ;;
  218.   ;; Type check the passed args.
  219.   ;;
  220.   (when (or (and int-minute (not int-hour))
  221.             (and (not int-minute) int-hour))
  222.     (error "Must supply both int-minute and int-hour, or neither."))
  223.   (when (and int-date-number
  224.              (not (typep int-date-number '(integer 1 31))))
  225.     (error "Int-date-number ~S was not an integer between 1 and 31 inclusive."
  226.            int-date-number))
  227.   (when (and int-date-number
  228.              (not int-month-number))
  229.     (error "Must supply int-month-number when passing int-date-number."))
  230.   (when (and int-day-of-week
  231.              (not (typep int-day-of-week '(integer 0 6))))
  232.     (error "Int-day-of-week ~S was not an integer between 0 and 6 inclusive."
  233.            int-day-of-week))
  234.   (when (and int-month-number
  235.              (not (typep int-month-number '(integer 1 12))))
  236.     (error "Int-month-number ~S was not an integer between 1 and 12 inclusive."
  237.            int-month-number))
  238.   (when (and int-day-of-week int-date-number int-month-number int-year)
  239.     (let ((ut (encode-universal-time 0 0 0
  240.                                      int-date-number int-month-number int-year)))
  241.       (multiple-value-bind (second minute hour date month year day-of-week)
  242.                            (decode-universal-time ut)
  243.         (declare (ignore second minute hour date month year))
  244.         ;;
  245.         (when (/= day-of-week int-day-of-week)
  246.           (error "Int-day-of-week ~S should have been ~S." int-day-of-week day-of-week)))))
  247.   ;;
  248.   (let* ((str-day (and int-day-of-week
  249.                        (elt '("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")
  250.                             int-day-of-week)))
  251.          (str-month (and int-month-number
  252.                          (elt '(nil "Jan" "Feb" "Mar" "Apr" "May" "Jun"
  253.                                 "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
  254.                               int-month-number)))
  255.          (str-year (and int-year (format nil "~4,'0D" int-year)))
  256.          (str-hour-minute (and int-hour int-minute
  257.                                (format nil "~2,'0D:~2,'0D" int-hour int-minute)))
  258.          (when-string ""))
  259.     ;;
  260.     ;; Build when-string .
  261.     ;;
  262.     (when str-hour-minute
  263.       (setf when-string str-hour-minute))
  264.     (when int-day-of-week
  265.       (setf when-string (concatenate 'string when-string "-" str-day)))
  266.     (when str-month
  267.       (setf when-string
  268.             (concatenate 'string when-string "-"
  269.                          (if int-date-number
  270.                            (format nil "~2,'0D-~A" int-date-number str-month)
  271.                            str-month))))
  272.     (when str-year
  273.       (setf when-string (concatenate 'string when-string "-" str-year)))
  274.     ;; Correct for leading #\- .
  275.     (setf when-string (string-left-trim "-" when-string))
  276.     ;; Return or error, as necessary.
  277.     (if (f-valid-when-str when-string)
  278.       when-string
  279.       (error "Couldn't construct a valid when string (made ~S)." when-string))))
  280.  
  281.  
  282. (defun when-string-now (&optional (f-include-hour-and-minute t))
  283.   "Returns a when-string based on the current value of get-decoded-time. If
  284. f-include-hour-and-minute is non-nil then they are included. Otherwise just
  285. the date, month, and year are included."
  286.   (declare (optimize speed))
  287.   ;;
  288.   (multiple-value-bind (second minute hour date month year day-of-week)
  289.                        (get-decoded-time)
  290.     (declare (ignore second day-of-week))
  291.     ;;
  292.     (if f-include-hour-and-minute
  293.       (when-string-make :int-minute minute :int-hour hour
  294.                         :int-date-number date
  295.                         :int-month-number month :int-year year
  296.                         ;:int-day-of-week day-of-week
  297.                         )
  298.       (when-string-make :int-date-number date
  299.                         :int-month-number month :int-year year))))
  300.  
  301.  
  302. ;;;================================================================
  303. ;;; Define support methods.
  304. ;;;================================================================
  305.  
  306. (defmethod l-field-specs-from-when-str ((when-string string))
  307.   "Returns a list of field specifiers encoded in when-string. Returns nil
  308. if when-string is invalid. Each field spec is a list of a kw-field-type as
  309. listed above and a field-value. Field values are as follows:
  310.  
  311. :time            - List of int-hour and int-minute.
  312. :day-of-week        - int-day-of-week
  313. :date-number        - int-date-number
  314. :month            - int-month-number
  315. :year            - int-year"
  316.   (declare (optimize speed))
  317.   ;;
  318.   (let ((l-field-specs ())
  319.         (l-str-fields ()))
  320.     ;;
  321.     ;; Build l-str-fields .
  322.     ;;
  323.     (let* ((int-num-dashes (count #\- when-string))
  324.            (int-pos-last-dash -1)
  325.            int-pos-next-dash str-field)
  326.       (dotimes (int-field-number (1+ int-num-dashes))
  327.         (setf int-pos-next-dash (position #\- when-string
  328.                                           :start (1+ int-pos-last-dash))
  329.               str-field (subseq when-string (1+ int-pos-last-dash)
  330.                                 int-pos-next-dash)
  331.               int-pos-last-dash int-pos-next-dash)
  332.         (when str-field (push str-field l-str-fields))))
  333.     ;;
  334.     ;; Build and return l-field-specs if it's valid.
  335.     ;;
  336.     (setf l-field-specs
  337.           (map 'list #'field-spec-from-str-field l-str-fields))
  338.     ;;
  339.     ;; Check constraints.
  340.     ;;
  341.     (if (or (null l-field-specs)
  342.             (member nil l-field-specs)
  343.             (and (member :date-number l-field-specs :key #'first)
  344.                  (not (member :month l-field-specs :key #'first)))
  345.             (let ((l-kw-field-type (map 'list #'first l-field-specs)))
  346.               (not (equal l-kw-field-type
  347.                           (remove-duplicates l-kw-field-type)))))
  348.       nil
  349.       l-field-specs)))
  350.  
  351.  
  352. (defmethod field-spec-from-str-field ((str-field string)
  353.                                      &aux (l-str-field (length str-field))
  354.                                      temp temp2)
  355.   "Returns a field-spec based on str-field or nil if string doesn't
  356. represent one."
  357.   ;;
  358.   (cond
  359.    ;; Check for :time
  360.    ((and (= l-str-field 5)
  361.          (setf temp (position #\: str-field)) 
  362.          (= temp 2)
  363.          (<= (char-code #\0) (char-code (elt str-field 0)) (char-code #\9))
  364.          (<= (char-code #\0) (char-code (elt str-field 1)) (char-code #\9))
  365.          (<= (char-code #\0) (char-code (elt str-field 3)) (char-code #\9))
  366.          (<= (char-code #\0) (char-code (elt str-field 4)) (char-code #\9))
  367.          (setf temp (read-from-string str-field nil :eof :start 0 :end 2))
  368.          (<= 0 temp 23)
  369.          (setf temp2 (read-from-string str-field nil :eof :start 3 :end 5))
  370.          (<= 0 temp2 59))
  371.     `(:time (,temp ,temp2)))
  372.    ;; Check for :day-of-week
  373.    ((and (= l-str-field 3)
  374.          (member (elt str-field 0) (coerce "MTWFS" 'list)  :test #'char-equal)
  375.          (setf temp (position (read-from-string str-field)
  376.                               '(MON TUE WED THU FRI SAT SUN))))
  377.     `(:day-of-week ,temp))
  378.    ;; Check for :date-number
  379.    ((and (= l-str-field 2)
  380.          (<= (char-code #\0) (char-code (elt str-field 0)) (char-code #\9))
  381.          (<= (char-code #\0) (char-code (elt str-field 1)) (char-code #\9))
  382.          (setf temp (read-from-string str-field))
  383.          (<= 1 temp 31))
  384.     `(:date-number ,temp))
  385.    ;; Check for :month
  386.    ((and (= l-str-field 3)
  387.          (member (elt str-field 0) (coerce "JFMASOND" 'list) :test #'char-equal)
  388.          (setf temp (position (read-from-string str-field)
  389.                               '(JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC))))
  390.     `(:month ,(1+ temp)))
  391.    ;; Check for :year
  392.    ((and (= l-str-field 4)
  393.          (<= (char-code #\0) (char-code (elt str-field 0)) (char-code #\9))
  394.          (<= (char-code #\0) (char-code (elt str-field 1)) (char-code #\9))
  395.          (<= (char-code #\0) (char-code (elt str-field 2)) (char-code #\9))
  396.          (<= (char-code #\0) (char-code (elt str-field 3)) (char-code #\9))
  397.          (setf temp (read-from-string str-field))
  398.          (>= temp 0))
  399.     `(:year ,temp))
  400.    ;;
  401.    (t nil)))
  402.  
  403.  
  404. ;;;================================================================
  405. ;;; Define support for f-when-str-matches-date and f-when-str-matches-month .
  406. ;;;================================================================
  407.  
  408. (defgeneric f-field-spec-matches-value (kw-field-type field-value
  409.                                        int-day-of-week int-date-number
  410.                                        int-month-number int-year)
  411.   (:documentation "Returns non-nil if kw-field-type and field-value match
  412. the information passed."))
  413.  
  414.  
  415. (defmethod f-field-spec-matches-value ((kw-field-type (eql :date-number))
  416.                                        (int-date-number-value integer)
  417.                                        int-day-of-week int-date-number
  418.                                        int-month-number int-year)
  419.   (declare (optimize speed)
  420.            (ignore int-day-of-week int-month-number int-year))
  421.   ;;
  422.   (= int-date-number-value int-date-number))
  423.  
  424.  
  425. (defmethod f-field-spec-matches-value ((kw-field-type (eql :month))
  426.                                        (int-month-number-value integer)
  427.                                        int-day-of-week int-date-number
  428.                                        int-month-number int-year)
  429.   (declare (optimize speed)
  430.            (ignore int-day-of-week int-date-number int-year))
  431.   ;;
  432.   (= int-month-number-value int-month-number))
  433.  
  434.  
  435. (defmethod f-field-spec-matches-value ((kw-field-type (eql :year))
  436.                                        (int-int-year-value integer)
  437.                                        int-day-of-week int-date-number
  438.                                        int-month-number int-year)
  439.   (declare (optimize speed)
  440.            (ignore int-day-of-week int-date-number int-month-number))
  441.   ;;
  442.   (= int-int-year-value int-year))
  443.  
  444.  
  445. (defmethod f-field-spec-matches-value ((kw-field-type (eql :day-of-week))
  446.                                        (int-day-of-week-value integer)
  447.                                        int-day-of-week int-date-number
  448.                                        int-month-number int-year)
  449.   (declare (optimize speed)
  450.            (ignore int-date-number int-month-number int-year))
  451.   ;;
  452.   (= int-day-of-week-value int-day-of-week))
  453.  
  454.  
  455. ;;;================================================================
  456. ;;; Done.
  457. ;;;================================================================
  458.  
  459. (provide "WHEN-STRINGS")
  460.  
  461.  
  462. #| ;;; Do some testing.
  463.  
  464. (defparameter *l-when-string* '("20:15-Thu" "Tue" "Wed"
  465.                                  "25-Dec" "22-Oct"
  466.                                  "22:33-11-May-1961" "21-Jan-1992")
  467.   "A list of when-strings for testing.")
  468.  
  469.  
  470. (map nil #'(lambda (when-string)
  471.              (format t "~&~S ->~20T~S" when-string
  472.                      (l-field-specs-from-when-str when-string)))
  473.      *l-when-string*)
  474.  
  475.  
  476. (let ((ut (get-universal-time)))
  477.   (multiple-value-bind (second minute hour date month year day-of-week)
  478.                        (decode-universal-time ut)
  479.     (declare (ignore second))
  480.     ;;
  481.     (let* ((str-month (elt '(nil "Jan" "Feb" "Mar" "Apr" "May" "Jun"
  482.                              "Jul" "Aug" "Sep" "Oct" "Nov" "Dec")
  483.                            month))
  484.            (str-day (elt '("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun")
  485.                          day-of-week))
  486.            (str-year (format nil "~:(~A~)" year))
  487.            (str-month-year (concatenate 'string str-month "-" str-year))
  488.            (str-hour-minute (format nil "~2,'0D:~2,'0D" hour minute))
  489.            (str-day-year (concatenate 'string str-day "-" str-year))
  490.            (str-date-month (format nil "~2,'0D-~A" date str-month)))
  491.       (labels ((print-it (when-string)
  492.                  (format t "~%~%~S ->~15T~S" when-string
  493.                          (f-when-str-matches-date when-string date month year))
  494.                  ;;
  495.                  (format t "~%~S ->~15T~{~S ~}" when-string
  496.                          (multiple-value-list (decode-when-str when-string)))))
  497.         (map nil #'print-it
  498.              (append
  499.               *l-when-string*
  500.               ;; These should all return true:
  501.               (list str-day str-month str-year str-month-year
  502.                     str-day-year str-hour-minute str-date-month)))))))
  503. |#